home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Info-Mac 3
/
Info_Mac_1994-01.iso
/
Development
/
General
/
XLisp 2.1e3
/
Sources
/
xlsubr.c
< prev
Wrap
Text File
|
1993-01-20
|
10KB
|
447 lines
/* xlsubr - xlisp builtin function support routines */
/* Copyright (c) 1985, by David Michael Betz
All Rights Reserved
Permission is granted for unrestricted non-commercial use */
#include "xlisp.h"
/* external variables */
extern LVAL k_test,k_tnot,s_eql;
extern LVAL true, s_termio, s_stdin, s_stdout;
/* xlsubr - define a builtin function */
#ifdef ANSI
LVAL xlsubr(char *sname, int type, LVAL (*fcn)(void),int offset)
#else
LVAL xlsubr(sname,type,fcn,offset)
char *sname; int type; LVAL (*fcn)(); int offset;
#endif
{
LVAL sym;
sym = xlenter(sname);
setfunction(sym,cvsubr(fcn,type,offset));
return (sym);
}
/* xlgetkeyarg - get a keyword argument */
int xlgetkeyarg(key,pval)
LVAL key,*pval;
{
LVAL *argv=xlargv;
int argc=xlargc;
for (argv = xlargv, argc = xlargc; (argc -= 2) >= 0; argv += 2) {
if (*argv == key) {
*pval = *++argv;
/* delete the used argument */
if (argc>0) memcpy(argv-1, argv+1, argc*sizeof(LVAL));
xlargc -=2;
return (TRUE);
}
}
return (FALSE);
}
/* xlgkfixnum - get a fixnum keyword argument */
int xlgkfixnum(key,pval)
LVAL key,*pval;
{
if (xlgetkeyarg(key,pval)) {
if (!fixp(*pval))
xlbadtype(*pval);
return (TRUE);
}
return (FALSE);
}
/* xltest - get the :test or :test-not keyword argument */
VOID xltest(pfcn,ptresult)
LVAL *pfcn; int *ptresult;
{
if (xlgetkeyarg(k_test,pfcn)) /* :test */
*ptresult = TRUE;
else if (xlgetkeyarg(k_tnot,pfcn)) /* :test-not */
*ptresult = FALSE;
else {
*pfcn = getfunction(s_eql);
*ptresult = TRUE;
}
}
/* xlgetfile - get a file or stream */
LVAL xlgetfile(outflag)
int outflag;
{
LVAL arg;
/* get a file or stream (cons) or nil */
if (null(arg = xlgetarg()))
return getvalue(outflag ? s_stdout: s_stdin);
else if (streamp(arg)) {
if (getfile(arg) == CLOSED)
xlfail("file not open");
}
else if (arg == true)
return getvalue(s_termio);
else if (!ustreamp(arg))
xlbadtype(arg);
return arg;
}
/* xlgetfname - get a filename */
LVAL xlgetfname()
{
LVAL name;
/* get the next argument */
name = xlgetarg();
/* get the filename string */
#ifdef FILETABLE
if (streamp(name) && getfile(name) > CONSOLE)
/* "Steal" name from file stream */
name = cvstring(filetab[getfile(name)].tname);
else
#endif
if (symbolp(name))
name = getpname(name);
else if (!stringp(name))
xlbadtype(name);
if (getslength(name) >= FNAMEMAX)
xlerror("file name too long", name);
/* return the name */
return (name);
}
/* needsextension - check if a filename needs an extension */
int needsextension(name)
char *name;
{
char *p;
#ifdef NO_EXTENSIONS
return (FALSE);
#else
/* check for an extension */
for (p = &name[strlen(name)]; --p >= &name[0]; )
if (*p == '.')
return (FALSE);
else if (!islower(*p) && !isupper(*p) && !isdigit(*p))
return (TRUE);
/* no extension found */
return (TRUE);
#endif
}
/* xlbadtype - report a "bad argument type" error */
LVAL xlbadtype(arg)
LVAL arg;
{
return xlerror("bad argument type",arg);
}
/* xltoofew - report a "too few arguments" error */
LVAL xltoofew()
{
xlfail("too few arguments");
return (NIL); /* never returns */
}
/* xltoomany - report a "too many arguments" error */
VOID xltoomany()
{
xlfail("too many arguments");
}
/* xltoolong - report a "too long to process" error */
VOID xltoolong()
{
xlfail("too long to process");
}
/* xlnoassign - report a "can't assign/bind to constant" error */
VOID xlnoassign(arg)
LVAL arg;
{
xlerror("can't assign/bind to constant", arg);
}
#ifdef COMPLX
/* compare floating point for eql and equal */
/* This is by Tom Almy */
#ifdef ANSI
static int NEAR comparecomplex(LVAL arg1, LVAL arg2)
#else
LOCAL int comparecomplex(arg1, arg2)
LVAL arg1, arg2;
#endif
{
LVAL r1=getelement(arg1,0), r2=getelement(arg2,0);
LVAL i1=getelement(arg1,1), i2=getelement(arg2,1);
if (ntype(r1) != ntype(r2)) return FALSE;
else if (ntype(r1) == FIXNUM)
return (getfixnum(r1)==getfixnum(r2)&&
getfixnum(i1)==getfixnum(i2));
else
return (getflonum(r1)==getflonum(r2)&&
getflonum(i1)==getflonum(i2));
}
#endif
/* eql - internal eql function */
int eql(arg1,arg2)
LVAL arg1,arg2;
{
/* compare the arguments */
if (arg1 == arg2)
return (TRUE);
else if (arg1 != NIL) {
switch (ntype(arg1)) {
case FIXNUM:
return (fixp(arg2) ? getfixnum(arg1)==getfixnum(arg2) : FALSE);
case FLONUM:
return (floatp(arg2) ? getflonum(arg1)==getflonum(arg2) : FALSE);
#ifdef COMPLX
case COMPLEX:
return (complexp(arg2) ? comparecomplex(arg1,arg2) : FALSE);
#endif
default:
return (FALSE);
}
}
else
return (FALSE);
}
#ifdef ANSI
static int NEAR stringcmp(LVAL arg1, LVAL arg2)
#else
LOCAL stringcmp(arg1, arg2) /* compare two strings for equal */
LVAL arg1, arg2; /* Written by TAA. Compares strings */
/* with embedded nulls */
#endif
{
char FAR *s1 = getstring(arg1), FAR *s2 = getstring(arg2);
unsigned l = getslength(arg1);
if (l != getslength(arg2)) return FALSE;
while (l-- > 0) if (*s1++ != *s2++) return FALSE;
return TRUE;
}
/* equal- internal equal function */
int equal(arg1,arg2)
LVAL arg1,arg2;
{
/* compare the arguments */
isItEqual: /* turn tail recursion into iteration */
if (arg1 == arg2)
return (TRUE);
else if (arg1 != NIL) {
switch (ntype(arg1)) {
case FIXNUM:
return (fixp(arg2) ? getfixnum(arg1)==getfixnum(arg2) : FALSE);
case FLONUM:
return (floatp(arg2) ? getflonum(arg1)==getflonum(arg2) : FALSE);
#ifdef COMPLX
case COMPLEX:
return (complexp(arg2) ? comparecomplex(arg1,arg2) : FALSE);
#endif
case STRING:
return (stringp(arg2) ? stringcmp(arg1,arg2) : FALSE); /* TAA MOD */
case CONS: /* TAA MOD turns tail recursion into iteration */
/* Not only is this faster, but greatly reduces chance */
/* of stack overflow */
if (consp(arg2) && equal(car(arg1),car(arg2))) {
arg1 = cdr(arg1);
arg2 = cdr(arg2);
goto isItEqual;
}
return FALSE;
default:
return (FALSE);
}
}
else
return (FALSE);
}
#ifdef KEYARG
/* TAA Addition */
/* xlkey - get the :key keyword argument */
extern LVAL k_key;
LVAL xlkey()
{
LVAL kfcn;
if (xlgetkeyarg(k_key,&kfcn)) return kfcn;
return NIL;
}
/* xlapp1 - apply a function of a single argument */
LVAL xlapp1(fun,arg)
LVAL fun,arg;
{
FRAMEP newfp;
/* create the new call frame */
newfp = xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(fun);
pusharg(cvfixnum((FIXTYPE)1));
pusharg(arg);
xlfp = newfp;
/* return the result of applying the function */
return xlapply(1);
}
/* dotest1 - call a test function with one argument */
int dotest1(arg,fun,kfun)
LVAL arg,fun,kfun;
{
FRAMEP newfp;
if (kfun != NIL) arg = xlapp1(kfun,arg);
/* create the new call frame */
newfp = xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(fun);
pusharg(cvfixnum((FIXTYPE)1));
pusharg(arg);
xlfp = newfp;
/* return the result of applying the test function */
return (xlapply(1) != NIL);
}
/* dotest2 - call a test function with two arguments */
int dotest2(arg1,arg2,fun,kfun)
LVAL arg1,arg2,fun,kfun;
{
FRAMEP newfp;
if (kfun != NIL) arg2 = xlapp1(kfun,arg2);
/* Speedup for default case TAA MOD */
if (fun == getfunction(s_eql))
return (eql(arg1,arg2));
/* create the new call frame */
newfp = xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(fun);
pusharg(cvfixnum((FIXTYPE)2));
pusharg(arg1);
pusharg(arg2);
xlfp = newfp;
/* return the result of applying the test function */
return (xlapply(2) != NIL);
}
/* dotest2s - call a test function with two arguments, symmetrical */
int dotest2s(arg1,arg2,fun,kfun)
LVAL arg1,arg2,fun,kfun;
{
FRAMEP newfp;
if (kfun != NIL) {
arg1 = xlapp1(kfun,arg1);
arg2 = xlapp1(kfun,arg2);
}
/* Speedup for default case TAA MOD */
if (fun == getfunction(s_eql))
return (eql(arg1,arg2));
/* create the new call frame */
newfp = xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(fun);
pusharg(cvfixnum((FIXTYPE)2));
pusharg(arg1);
pusharg(arg2);
xlfp = newfp;
/* return the result of applying the test function */
return (xlapply(2) != NIL);
}
#else
/* dotest1 - call a test function with one argument */
int dotest1(arg,fun)
LVAL arg,fun;
{
FRAMEP newfp;
/* create the new call frame */
newfp = xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(fun);
pusharg(cvfixnum((FIXTYPE)1));
pusharg(arg);
xlfp = newfp;
/* return the result of applying the test function */
return (xlapply(1) != NIL);
}
/* dotest2 - call a test function with two arguments */
int dotest2(arg1,arg2,fun)
LVAL arg1,arg2,fun;
{
FRAMEP newfp;
/* Speedup for default case TAA MOD */
if (fun == getfunction(s_eql))
return (eql(arg1,arg2));
/* create the new call frame */
newfp = xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(fun);
pusharg(cvfixnum((FIXTYPE)2));
pusharg(arg1);
pusharg(arg2);
xlfp = newfp;
/* return the result of applying the test function */
return (xlapply(2) != NIL);
}
#endif
#ifdef COMPLX
/* return value of a number coerced to a FLOTYPE */
FLOTYPE makefloat(x)
LVAL x;
{
if (fixp(x)) return ((FLOTYPE) getfixnum(x));
else if (floatp(x)) return getflonum(x);
#ifdef RATIOS
else if (ratiop(x)) return (getnumer(x)/(FLOTYPE)getdenom(x));
#endif
xlerror("not a number", x);
return 0.0; /* never reached */
}
#endif